home *** CD-ROM | disk | FTP | other *** search
/ NeXT Education Software Sampler 1992 Fall / NeXT Education Software Sampler 1992 Fall.iso / Programming / Source / winterp-1.13 / src-server / xlisp / xlsym.c < prev    next >
Encoding:
C/C++ Source or Header  |  1991-10-04  |  6.9 KB  |  282 lines
  1. /* -*-C-*-
  2. ********************************************************************************
  3. *
  4. * File:         xlsym.c
  5. * RCS:          $Header: xlsym.c,v 1.4 91/03/24 22:25:36 mayer Exp $
  6. * Description:  symbol handling routines
  7. * Author:       David Michael Betz
  8. * Created:      
  9. * Modified:     Fri Oct  4 04:12:57 1991 (Niels Mayer) mayer@hplnpm
  10. * Language:     C
  11. * Package:      N/A
  12. * Status:       X11r5 contrib tape release
  13. *
  14. * WINTERP Copyright 1989, 1990, 1991 Hewlett-Packard Company (by Niels Mayer).
  15. * XLISP version 2.1, Copyright (c) 1989, by David Betz.
  16. *
  17. * Permission to use, copy, modify, distribute, and sell this software and its
  18. * documentation for any purpose is hereby granted without fee, provided that
  19. * the above copyright notice appear in all copies and that both that
  20. * copyright notice and this permission notice appear in supporting
  21. * documentation, and that the name of Hewlett-Packard and David Betz not be
  22. * used in advertising or publicity pertaining to distribution of the software
  23. * without specific, written prior permission.  Hewlett-Packard and David Betz
  24. * make no representations about the suitability of this software for any
  25. * purpose. It is provided "as is" without express or implied warranty.
  26. *
  27. * HEWLETT-PACKARD AND DAVID BETZ DISCLAIM ALL WARRANTIES WITH REGARD TO THIS
  28. * SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS,
  29. * IN NO EVENT SHALL HEWLETT-PACKARD NOR DAVID BETZ BE LIABLE FOR ANY SPECIAL,
  30. * INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM
  31. * LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE
  32. * OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR
  33. * PERFORMANCE OF THIS SOFTWARE.
  34. *
  35. * See ./winterp/COPYRIGHT for information on contacting the authors.
  36. * 
  37. * Please send modifications, improvements and bugfixes to mayer@hplabs.hp.com
  38. * Post XLISP-specific questions/information to the newsgroup comp.lang.lisp.x
  39. *
  40. ********************************************************************************
  41. */
  42. static char rcs_identity[] = "@(#)$Header: xlsym.c,v 1.4 91/03/24 22:25:36 mayer Exp $";
  43.  
  44.  
  45. #include "xlisp.h"
  46.  
  47. /* external variables */
  48. extern LVAL obarray,s_unbound;
  49. extern LVAL xlenv,xlfenv,xldenv;
  50.  
  51. /* forward declarations */
  52. LOCAL FORWARD LVAL findprop();    /* NPM: changed this to LOCAL */
  53.  
  54. /* xlenter - enter a symbol into the obarray */
  55. LVAL xlenter(name)
  56.   char *name;
  57. {
  58.     LVAL sym,array;
  59.     int i;
  60.  
  61.     /* check for nil */
  62.     if (strcmp(name,"NIL") == 0)
  63.     return (NIL);
  64.  
  65.     /* check for symbol already in table */
  66.     array = getvalue(obarray);
  67.     i = hash(name,HSIZE);
  68.     for (sym = getelement(array,i); sym; sym = cdr(sym))
  69.     if (strcmp(name,getstring(getpname(car(sym)))) == 0)
  70.         return (car(sym));
  71.  
  72.     /* make a new symbol node and link it into the list */
  73.     xlsave1(sym);
  74.     sym = consd(getelement(array,i));
  75.     rplaca(sym,xlmakesym(name));
  76.     setelement(array,i,sym);
  77.     xlpop();
  78.  
  79.     /* return the new symbol */
  80.     return (car(sym));
  81. }
  82.  
  83. /* xlmakesym - make a new symbol node */
  84. LVAL xlmakesym(name)
  85.   char *name;
  86. {
  87.     LVAL sym;
  88.     sym = cvsymbol(name);
  89.     if (*name == ':')
  90.     setvalue(sym,sym);
  91.     return (sym);
  92. }
  93.  
  94. /* xlgetvalue - get the value of a symbol (with check) */
  95. LVAL xlgetvalue(sym)
  96.   LVAL sym;
  97. {
  98.     LVAL val;
  99.  
  100.     /* look for the value of the symbol */
  101.     while ((val = xlxgetvalue(sym)) == s_unbound)
  102.     xlunbound(sym);
  103.  
  104.     /* return the value */
  105.     return (val);
  106. }
  107.  
  108. /* xlxgetvalue - get the value of a symbol */
  109. LVAL xlxgetvalue(sym)
  110.   LVAL sym;
  111. {
  112.     register LVAL fp,ep;
  113.     LVAL val;
  114.  
  115.     /* check the environment list */
  116.     for (fp = xlenv; fp; fp = cdr(fp))
  117.  
  118.     /* check for an instance variable */
  119.     if ((ep = car(fp)) && objectp(car(ep))) {
  120.         if (xlobgetvalue(ep,sym,&val))
  121.         return (val);
  122.     }
  123.  
  124.     /* check an environment stack frame */
  125.     else {
  126.         for (; ep; ep = cdr(ep))
  127.         if (sym == car(car(ep)))
  128.             return (cdr(car(ep)));
  129.     }
  130.  
  131.     /* return the global value */
  132.     return (getvalue(sym));
  133. }
  134.  
  135. /* xlsetvalue - set the value of a symbol */
  136. xlsetvalue(sym,val)
  137.   LVAL sym,val;
  138. {
  139.     register LVAL fp,ep;
  140.  
  141.     /* look for the symbol in the environment list */
  142.     for (fp = xlenv; fp; fp = cdr(fp))
  143.  
  144.     /* check for an instance variable */
  145.     if ((ep = car(fp)) && objectp(car(ep))) {
  146.         if (xlobsetvalue(ep,sym,val))
  147.         return;
  148.     }
  149.  
  150.     /* check an environment stack frame */
  151.     else {
  152.         for (; ep; ep = cdr(ep))
  153.         if (sym == car(car(ep))) {
  154.             rplacd(car(ep),val);
  155.             return;
  156.         }
  157.     }
  158.  
  159.     /* store the global value */
  160.     setvalue(sym,val);
  161. }
  162.  
  163. /* xlgetfunction - get the functional value of a symbol (with check) */
  164. LVAL xlgetfunction(sym)
  165.   LVAL sym;
  166. {
  167.     LVAL val;
  168.  
  169.     /* look for the functional value of the symbol */
  170.     while ((val = xlxgetfunction(sym)) == s_unbound)
  171.     xlfunbound(sym);
  172.  
  173.     /* return the value */
  174.     return (val);
  175. }
  176.  
  177. /* xlxgetfunction - get the functional value of a symbol */
  178. LVAL xlxgetfunction(sym)
  179.   LVAL sym;
  180. {
  181.     register LVAL fp,ep;
  182.  
  183.     /* check the environment list */
  184.     for (fp = xlfenv; fp; fp = cdr(fp))
  185.     for (ep = car(fp); ep; ep = cdr(ep))
  186.         if (sym == car(car(ep)))
  187.         return (cdr(car(ep)));
  188.  
  189.     /* return the global value */
  190.     return (getfunction(sym));
  191. }
  192.  
  193. /* xlsetfunction - set the functional value of a symbol */
  194. xlsetfunction(sym,val)
  195.   LVAL sym,val;
  196. {
  197.     register LVAL fp,ep;
  198.  
  199.     /* look for the symbol in the environment list */
  200.     for (fp = xlfenv; fp; fp = cdr(fp))
  201.     for (ep = car(fp); ep; ep = cdr(ep))
  202.         if (sym == car(car(ep))) {
  203.         rplacd(car(ep),val);
  204.         return;
  205.         }
  206.  
  207.     /* store the global value */
  208.     setfunction(sym,val);
  209. }
  210.  
  211. /* xlgetprop - get the value of a property */
  212. LVAL xlgetprop(sym,prp)
  213.   LVAL sym,prp;
  214. {
  215.     LVAL p;
  216.     return ((p = findprop(sym,prp)) ? car(p) : NIL);
  217. }
  218.  
  219. /* xlputprop - put a property value onto the property list */
  220. xlputprop(sym,val,prp)
  221.   LVAL sym,val,prp;
  222. {
  223.     LVAL pair;
  224.     if (pair = findprop(sym,prp))
  225.     rplaca(pair,val);
  226.     else
  227.     setplist(sym,cons(prp,cons(val,getplist(sym))));
  228. }
  229.  
  230. /* xlremprop - remove a property from a property list */
  231. xlremprop(sym,prp)
  232.   LVAL sym,prp;
  233. {
  234.     LVAL last,p;
  235.     last = NIL;
  236.     for (p = getplist(sym); consp(p) && consp(cdr(p)); p = cdr(last)) {
  237.     if (car(p) == prp)
  238.         if (last)
  239.         rplacd(last,cdr(cdr(p)));
  240.         else
  241.         setplist(sym,cdr(cdr(p)));
  242.     last = cdr(p);
  243.     }
  244. }
  245.  
  246. /* findprop - find a property pair */
  247. LOCAL LVAL findprop(sym,prp)
  248.   LVAL sym,prp;
  249. {
  250.     LVAL p;
  251.     for (p = getplist(sym); consp(p) && consp(cdr(p)); p = cdr(cdr(p)))
  252.     if (car(p) == prp)
  253.         return (cdr(p));
  254.     return (NIL);
  255. }
  256.  
  257. /* hash - hash a symbol name string */
  258. int hash(str,len)
  259.   char *str;
  260. {
  261.     int i;
  262.     for (i = 0; *str; )
  263.     i = (i << 2) ^ *str++;
  264.     i %= len;
  265.     return (i < 0 ? -i : i);
  266. }
  267.  
  268. /* xlsinit - symbol initialization routine */
  269. xlsinit()
  270. {
  271.     LVAL array,p;
  272.  
  273.     /* initialize the obarray */
  274.     obarray = xlmakesym("*OBARRAY*");
  275.     array = newvector(HSIZE);
  276.     setvalue(obarray,array);
  277.  
  278.     /* add the symbol *OBARRAY* to the obarray */
  279.     p = consa(obarray);
  280.     setelement(array,hash("*OBARRAY*",HSIZE),p);
  281. }
  282.